Documentation: This takes simulations from the cooperative corruption simulations and plots them.

Simulations depend on CoopCor function in ABM.rmd file

I. PROTOTYPICAL SCENARIOS

Read in the data saved

simulation_files <- list.files("data/sims/sim_plots/")
scenarios <- list()

for(i in seq_along(simulation_files)){
  scenarios[[i]] <- read_csv(paste0("data/sims/sim_plots/",simulation_files[i]))
}
## Parsed with column specification:
## cols(
##   P1_roll = col_integer(),
##   P2_roll = col_integer(),
##   P1_cheat = col_integer(),
##   P2_cheat = col_integer(),
##   check = col_integer(),
##   cheated = col_integer(),
##   payoff = col_double(),
##   th_payoff = col_integer(),
##   ingame = col_integer(),
##   n_game = col_integer()
## )
## Parsed with column specification:
## cols(
##   P1_roll = col_integer(),
##   P2_roll = col_integer(),
##   P1_cheat = col_integer(),
##   P2_cheat = col_integer(),
##   check = col_integer(),
##   cheated = col_integer(),
##   payoff = col_double(),
##   th_payoff = col_integer(),
##   ingame = col_integer(),
##   n_game = col_integer()
## )
## Parsed with column specification:
## cols(
##   P1_roll = col_integer(),
##   P2_roll = col_integer(),
##   P1_cheat = col_integer(),
##   P2_cheat = col_integer(),
##   check = col_integer(),
##   cheated = col_integer(),
##   payoff = col_integer(),
##   th_payoff = col_integer(),
##   ingame = col_integer(),
##   n_game = col_integer()
## )
## Parsed with column specification:
## cols(
##   P1_roll = col_integer(),
##   P2_roll = col_integer(),
##   P1_cheat = col_integer(),
##   P2_cheat = col_integer(),
##   check = col_integer(),
##   cheated = col_integer(),
##   payoff = col_double(),
##   th_payoff = col_integer(),
##   ingame = col_integer(),
##   n_game = col_integer()
## )
## Parsed with column specification:
## cols(
##   P1_roll = col_integer(),
##   P2_roll = col_integer(),
##   P1_cheat = col_integer(),
##   P2_cheat = col_integer(),
##   check = col_integer(),
##   cheated = col_integer(),
##   payoff = col_double(),
##   th_payoff = col_integer(),
##   ingame = col_integer(),
##   n_game = col_integer()
## )
## Parsed with column specification:
## cols(
##   P1_roll = col_integer(),
##   P2_roll = col_integer(),
##   P1_cheat = col_integer(),
##   P2_cheat = col_integer(),
##   check = col_integer(),
##   cheated = col_integer(),
##   payoff = col_integer(),
##   th_payoff = col_integer(),
##   ingame = col_integer(),
##   n_game = col_integer()
## )
## Parsed with column specification:
## cols(
##   P1_roll = col_integer(),
##   P2_roll = col_integer(),
##   P1_cheat = col_integer(),
##   P2_cheat = col_integer(),
##   check = col_integer(),
##   cheated = col_integer(),
##   payoff = col_double(),
##   th_payoff = col_integer(),
##   ingame = col_integer(),
##   n_game = col_integer()
## )
## Parsed with column specification:
## cols(
##   P1_roll = col_integer(),
##   P2_roll = col_integer(),
##   P1_cheat = col_integer(),
##   P2_cheat = col_integer(),
##   check = col_integer(),
##   cheated = col_integer(),
##   payoff = col_integer(),
##   th_payoff = col_integer(),
##   ingame = col_integer(),
##   n_game = col_integer()
## )
## Parsed with column specification:
## cols(
##   P1_roll = col_integer(),
##   P2_roll = col_integer(),
##   P1_cheat = col_integer(),
##   P2_cheat = col_integer(),
##   check = col_integer(),
##   cheated = col_integer(),
##   payoff = col_integer(),
##   th_payoff = col_integer(),
##   ingame = col_integer(),
##   n_game = col_integer()
## )
names(scenarios) <- str_remove(simulation_files, ".csv")




scenario_summaries <- list()

for(i in (seq_along(scenarios))){
  scenario_summaries[[i]] <- assign(paste(names(scenarios)[i], "summary", sep = "_"), scenarios[[i]]) %>% 
    group_by(n_game) %>%
    mutate(turnID = row_number()) %>%
    ungroup()
  names(scenario_summaries)[i] <- names(scenarios)[i]
  }

scenario_full <- plyr::ldply(scenario_summaries, data.frame) %>%
  mutate(is_heuristic = ifelse(.id == "TheoreticalLeader" | .id == "BiasedLeader",1,0))

scenario_comparison <- scenario_full %>%        
  group_by(turnID,.id) %>%
  summarise(is_heuristic = mean(cumprod(is_heuristic)),
            mean_pay = mean(payoff),
            std = sd(payoff),
            N = n(),
            se = std/sqrt(N),
            lowbeta = mean(qbeta(0.025, payoff + .5, N - payoff + .5)),
            highbeta = mean(qbeta(0.975, payoff + .5, N - payoff + .5))) %>%
  ungroup() %>%
  group_by(.id) %>%
  mutate(cum_pay = cumsum(mean_pay))

How much money have groups actually made (i.e. when being caught = 0)?

#We summarise the full dataset
game_summaries <- scenario_full %>% group_by(.id,n_game) %>%
  summarise(total_pay = sum(payoff),
            ingame_dummy = min(cumprod(ingame)),
            is_heuristic = min(cumprod(is_heuristic))) %>%
  mutate(actual_pay = ifelse(ingame_dummy == 0, 0, total_pay))


###### Raincloud Plot
#with all scenarios
game_summaries %>%
  ungroup() %>%
  mutate(.id = fct_reorder(.id, desc(actual_pay))) %>%
  ggplot(aes(x = .id, y = actual_pay, fill = .id)) +
  geom_flat_violin(position = position_nudge(x = .2, y = 0)) +
  geom_point(aes(color = .id),position = position_jitter(width = .15), size = .2) +
  geom_boxplot(width = .1, alpha = 0.5, outlier.shape = NA, show.legend = FALSE) +
  scale_fill_manual(values = ggsci::pal_aaas()(9)) +
  scale_color_manual(values = ggsci::pal_aaas()(9)) +
  labs(title = "Payouts Raincloud Plot", x = "Scenarios", y = "Actual Payouts") +
  coord_flip() +
  theme_minimal(base_size = 24) +
  guides(fill = FALSE, color = FALSE)

#ggsave("figures/RaincloudPlot_actual_payouts_ALL.png", device = "png", width = 15, height = 10)

#without smart leaders
game_summaries %>%
  ungroup() %>%
  filter(is_heuristic == 0) %>%
  mutate(.id = fct_reorder(.id, desc(actual_pay))) %>%
  ggplot(aes(x = .id, y = actual_pay, fill = .id)) +
  geom_flat_violin(position = position_nudge(x = .2, y = 0)) +
  geom_point(aes(color = .id),position = position_jitter(width = .15), size = .2) +
  geom_boxplot(width = .1, alpha = 0.5, outlier.shape = NA, show.legend = FALSE) +
  scale_fill_manual(values = ggsci::pal_aaas()(9)) +
  scale_color_manual(values = ggsci::pal_aaas()(9)) +
  labs(title = "Payouts Raincloud Plot", x = "Scenarios", y = "Actual Payouts") +
  coord_flip() +
  theme_minimal(base_size = 24) +
  guides(fill = FALSE, color = FALSE)

#ggsave("figures/RaincloudPlot_actual_payouts_no_heuristics.png", device = "png", width = 15, height = 10)


####### Simple bar plot
#with all scenarios
game_summaries %>%
  group_by(.id) %>%
  summarise(mean_actual_pay = mean(actual_pay),
            N = n(),
            std = sd(actual_pay),
            se = std/sqrt(N)) %>%
  mutate(.id = fct_reorder(.id, desc(mean_actual_pay))) %>%
  ggplot(aes(x = .id, y = mean_actual_pay, fill = .id)) +
  geom_bar(stat = "identity") +
  geom_errorbar(aes(ymin = mean_actual_pay - se, ymax = mean_actual_pay + se), width = 0.3) +
  scale_fill_manual(values = ggsci::pal_aaas()(9)) +
  theme(axis.text = element_text(angle = 45, hjust = 1)) +
  labs(title = "Mean Actual Payouts by Scenario (N = 1000)", fill = "Scenario", x = "Scenarios", y = "Mean Actual Payout" )

#ggsave("figures/mean_actual_payouts.png", device = "png", width = 15, height = 7.5)

#witohut smart leaders
game_summaries %>%
  filter(is_heuristic == 0) %>%
  group_by(.id) %>%
  summarise(mean_actual_pay = mean(actual_pay),
            N = n(),
            std = sd(actual_pay),
            se = std/sqrt(N)) %>%
  mutate(.id = fct_reorder(.id, desc(mean_actual_pay))) %>%
  ggplot(aes(x = .id, y = mean_actual_pay, fill = .id)) +
  geom_bar(stat = "identity") +
  geom_errorbar(aes(ymin = mean_actual_pay - se, ymax = mean_actual_pay + se), width = 0.3) +
  scale_fill_manual(values = ggsci::pal_aaas()(9)) +
  theme(axis.text = element_text(angle = 45, hjust = 1)) +
  labs(title = "Mean Actual Payouts by Scenario (N = 1000)", fill = "Scenario", x = "Scenarios", y = "Mean Actual Payout" )

#ggsave("figures/mean_actual_payouts_no_heuristics.png", device = "png", width = 15, height = 7.5)

II. SMART AND ETHICAL LEADERS

Read in the datasets

sim_comb_sum <- read.csv("data/sims/leader_heuristic/sim_comb_sum.csv")
sim_comb <- read.csv("data/sims/leader_heuristic/sim_comb.csv")

About money?

#The mean cumulative pay:
#The total money a team makes, averaged over number of games

#mean cumulative pay by round number
sim_comb_sum %>%
  ggplot(aes(x = turnID, y = mean_cum_actual_pay, color = bias)) +
  geom_line(aes(group = bias)) +
  scale_color_gradient2(low = "green", mid = "yellow", high = "red", midpoint = 0.5) +
  facet_wrap(~heuristic)

What is the state of the games at last round?

rounds=100
#Creating a dataframe with data only from last round
sim_comb_max <- sim_comb_sum %>%
  filter(turnID == rounds)


sim_comb_max %>% ggplot(aes(x = bias, y = mean_cum_actual_pay, fill = heuristic)) +
  geom_bar(stat = "identity", position = "dodge")

## At last round

## What we have when the game ends
#gains for each cheating bias and heuristic, averaged over the 250 games
sim_comb_max %>% ggplot(aes(x = bias, y = mean_cum_pay, color = heuristic)) +
  geom_point() + geom_smooth(method = 'lm')

#actual gains (accounting for failed games) for each cheating bias and heuristic, averaged over the 250 games
sim_comb_max %>% ggplot(aes(x = bias, y = mean_cum_actual_pay, color = heuristic)) +
  geom_point() + geom_smooth()
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

#total lost games on 250 runs by bias and heuristics
sim_comb_max %>% ggplot(aes(x = bias, y = sum_lost_game, color = heuristic)) +
  geom_point() + geom_smooth()
## `geom_smooth()` using method = 'loess' and formula 'y ~ x'

Everything about the dynamics between checks and cheats: We have 2*2 possibilities -A check matched by a cheat: good job! -A check without a cheat: you’re being too suspicious, you wasted the company’s money -No check but cheat: you failed at your job -No check no cheat: we don’t care so much

#overall checking
sim_comb_sum %>%
  ggplot(aes(x = bias, y = sum_checks, color = heuristic)) +
  geom_point() +
  geom_smooth()
## `geom_smooth()` using method = 'gam' and formula 'y ~ s(x, bs = "cs")'

#failed checks
sim_comb_sum %>%
  ggplot(aes(x = bias, y = sum_unchecked_cheat, color = heuristic)) +
  geom_point() +
  geom_smooth()
## `geom_smooth()` using method = 'gam' and formula 'y ~ s(x, bs = "cs")'

#successeful checks
sim_comb_sum %>%
  ggplot(aes(x = bias, y = sum_checked_cheat, color = heuristic)) +
  geom_point() +
  geom_smooth()
## `geom_smooth()` using method = 'gam' and formula 'y ~ s(x, bs = "cs")'

#unnecessary checks
sim_comb_sum %>%
  ggplot(aes(x = bias, y = sum_useless_check, color = heuristic)) +
  geom_point() +
  geom_smooth()
## `geom_smooth()` using method = 'gam' and formula 'y ~ s(x, bs = "cs")'

###The evolution of checks across runs by bias
#failed checks
sim_comb_sum %>%
  ggplot(aes(x = turnID, y = sum_unchecked_cheat, color = bias)) +
  geom_line(aes(group = bias)) +
  scale_color_gradient2(low = "green", mid = "yellow", high = "red", midpoint = 0.5) +
  facet_wrap(~heuristic)

#succesfull checks
sim_comb_sum %>%
  ggplot(aes(x = turnID, y = sum_checked_cheat, color = bias)) +
  geom_line(aes(group = bias)) +
  scale_color_gradient2(low = "green", mid = "yellow", high = "red", midpoint = 0.5) +
  facet_wrap(~heuristic)

#unnecessary checks
sim_comb_sum %>%
  ggplot(aes(x = turnID, y = sum_useless_check, color = bias)) +
  geom_line(aes(group = bias)) +
  scale_color_gradient2(low = "green", mid = "yellow", high = "red", midpoint = 0.5) +
  facet_wrap(~heuristic)

It seems that:

On the cumulative payoff -With a forgiving leader, any amount of cheating brings better results -With a grudgy leader, any amount of cheating brings worst results

When taking into account the failed games (payoff drops to 0 because of GREED and BAD LUCK) On the actual cumulative pay off -Never cheating still brings the best result -Having a grudgy leader leads to a drastic decrease of gains the more cheating happens -Having a forgiving leader leads to slight decrease of gains when cheating increases